home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog6.arj / CURSOR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  4.4 KB  |  165 lines
  1. { cursor.pas -- Display built-in and custom cursors }
  2.  
  3. program Cursor;
  4.  
  5. {$R cursor.res}
  6.  
  7. uses WinTypes, WinProcs, WObjects;
  8.  
  9. const
  10.  
  11.   id_Menu     = 100;    { Menu resource ID }
  12.   id_Cursor   = 200;    { Custom cursor resource ID }
  13.  
  14.   cm_Arrow    = 101;    { Menu command values }
  15.   cm_Cross    = 102;
  16.   cm_IBeam    = 103;
  17.   cm_Icon     = 104;
  18.   cm_Size     = 105;
  19.   cm_SizeNESW = 106;
  20.   cm_SizeNS   = 107;
  21.   cm_SizeNWSE = 108;
  22.   cm_SizeWE   = 109;
  23.   cm_UpArrow  = 110;
  24.   cm_Wait     = 111;
  25.  
  26.   firstCommand = cm_Arrow;    { First and last command constants }
  27.   lastCommand = cm_Wait;
  28.  
  29. type
  30.  
  31.   CursorApplication = object(TApplication)
  32.     procedure InitMainWindow; virtual;
  33.   end;
  34.  
  35.   PCursorWindow = ^CursorWindow;
  36.   CursorWindow = object(TWindow)
  37.     ButtonDown: Boolean;
  38.     CurCustom, CurCurrent: HCursor;
  39.     CurCommand: Word;
  40.     CursorHandles: array[firstCommand .. lastCommand] of HCursor;
  41.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  42.     procedure GetWindowClass(var AWndClass: TWndClass);
  43.       virtual;
  44.     procedure WMCommand(var Msg: TMessage);
  45.       virtual wm_First + wm_Command;
  46.     procedure WMLButtonDown(var Msg: TMessage);
  47.       virtual wm_First + wm_LButtonDown;
  48.     procedure WMLButtonUp(var Msg: TMessage);
  49.       virtual wm_First + wm_LButtonUp;
  50.   end;
  51.  
  52.  
  53. {- Toggle a checkmarked menu item on or off }
  54. procedure ToggleCheck(Menu: HMenu; MenuItemID: Word);
  55. var
  56.   MAttr, WCheck: Word;
  57. begin
  58.   MAttr := GetMenuState(Menu, MenuItemID, mf_ByCommand);
  59.   if (MAttr and mf_Checked) = mf_Checked then
  60.     WCheck := mf_ByCommand or mf_Unchecked
  61.   else
  62.     WCheck := mf_ByCommand or mf_Checked;
  63.   CheckMenuItem(Menu, MenuItemID, WCheck)
  64. end;
  65.  
  66.  
  67. { CursorApplication }
  68.  
  69. {- Initialize CursorApplication object's window }
  70. procedure CursorApplication.InitMainWindow;
  71. begin
  72.   MainWindow := New(PCursorWindow, Init(nil,
  73.     'Click left mouse button to use selected cursor'))
  74. end;
  75.  
  76.  
  77. { CursorWindow }
  78.  
  79. {- Construct CursorWindow object }
  80. constructor CursorWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  81. var
  82.   I: Integer;
  83. begin
  84.   TWindow.Init(AParent, ATitle);
  85.   Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  86.   ButtonDown := false;
  87.   CurCustom := LoadCursor(HInstance, PChar(id_Cursor));
  88.   CursorHandles[cm_Arrow]    := LoadCursor(0, idc_Arrow);
  89.   CursorHandles[cm_IBeam]    := LoadCursor(0, idc_IBeam);
  90.   CursorHandles[cm_Wait]     := LoadCursor(0, idc_Wait);
  91.   CursorHandles[cm_Cross]    := LoadCursor(0, idc_Cross);
  92.   CursorHandles[cm_UPArrow]  := LoadCursor(0, idc_UPArrow);
  93.   CursorHandles[cm_Size]     := LoadCursor(0, idc_Size);
  94.   CursorHandles[cm_Icon]     := LoadCursor(0, idc_Icon);
  95.   CursorHandles[cm_SizeNWSE] := LoadCursor(0, idc_SizeNWSE);
  96.   CursorHandles[cm_SizeNESW] := LoadCursor(0, idc_SizeNESW);
  97.   CursorHandles[cm_SizeWE]   := LoadCursor(0, idc_SizeWE);
  98.   CursorHandles[cm_SizeNS]   := LoadCursor(0, idc_SizeNS);
  99.   CurCurrent := CursorHandles[cm_Arrow];
  100.   CurCommand := cm_Arrow;
  101.   ToggleCheck(Attr.Menu, CurCommand)
  102. end;
  103.  
  104. {- Modify window class to use custom cursor }
  105. procedure CursorWindow.GetWindowClass(var AWndClass: TWndClass);
  106. begin
  107.   TWindow.GetWindowClass(AWndClass);
  108.   AWndClass.HCursor := CurCustom; (*LoadCursor(0, idc_UpArrow)*)
  109. end;
  110.  
  111. {- Intercept wm_Command messages }
  112. procedure CursorWindow.WMCommand(var Msg: TMessage);
  113. begin
  114.   with Msg do
  115.   case WParam of
  116.     firstCommand .. lastCommand:
  117.     begin
  118.       CurCurrent := CursorHandles[WParam];
  119.       ToggleCheck(Attr.Menu, CurCommand);
  120.       ToggleCheck(Attr.Menu, WParam);
  121.       CurCommand := WParam
  122.     end
  123.   else
  124.     TWindow.WMCommand(Msg)
  125.   end
  126. end;
  127.  
  128. {- Respond to left mouse button down events }
  129. procedure CursorWindow.WMLButtonDown(var Msg: TMessage);
  130. begin
  131.   if not ButtonDown then with Msg do
  132.   begin
  133.     ButtonDown := true;
  134.     SetCursor(CurCurrent);
  135.     SetCapture(HWindow)
  136.   end
  137. end;
  138.  
  139. {- Respond to left mouse button up events }
  140. procedure CursorWindow.WMLButtonUp(var Msg: TMessage);
  141. begin
  142.   if ButtonDown then with Msg do
  143.   begin
  144.     ButtonDown := false;
  145.     SetCursor(CurCustom);
  146.     ReleaseCapture
  147.   end
  148. end;
  149.  
  150. var
  151.  
  152.   CursorApp: CursorApplication;
  153.  
  154. begin
  155.   CursorApp.Init('CursorApp');
  156.   CursorApp.Run;
  157.   CursorApp.Done
  158. end.
  159.  
  160.  
  161. {--------------------------------------------------------------
  162.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  163.   Revision 1.00    Date: 3/09/1991
  164. ---------------------------------------------------------------}
  165.